home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / guile-docs / tcltk-wkshp / talk-html / game.scw < prev    next >
Encoding:
Text File  |  1995-07-05  |  8.1 KB  |  372 lines
  1. (require 'Gwish)
  2. (require 'random)
  3. (toplevel '.game)
  4.  
  5.  
  6. ;; How big a canvas?
  7. ;;
  8. (define play-w 520)
  9. (define play-h 520)
  10.  
  11. ;; Where does the play area start
  12. ;;
  13. (define bounds-x 4)
  14. (define bounds-y 4)
  15.  
  16. ;; Where is the paddle ul cornder?
  17. ;;
  18. (define paddle-x 0)
  19. (define paddle-y 375)
  20.  
  21. ;; Where is the puck center?
  22. ;;
  23. (define puck-x 0)
  24. (define puck-r 5)
  25. (define puck-y (- paddle-y puck-r 1))
  26.  
  27. ;; Paddle size:
  28. ;;
  29. (define paddle-height 10)
  30. (define paddle-width 64)
  31.  
  32. ;; How big is the in-bounds area for the puck?
  33. ;;
  34. (define bounds-w 512)
  35. (define bounds-h puck-y)
  36.  
  37. ;; How many blocks per row?
  38. ;;
  39. (define n-row 16)
  40.  
  41. ;; Row y positions
  42. ;;
  43. (define row0-y 32)
  44. (define row1-y 64)
  45.  
  46. ;; Individual block size
  47. ;;
  48. (define row-height 16)
  49. (define row-width (/ bounds-w n-row))
  50.  
  51. ;; Each entry either the name of a canvas
  52. ;; item for the block or #f if the block
  53. ;; has been eliminated:
  54. ;;
  55. (define row0 (make-vector n-row #f))
  56. (define row1 (make-vector n-row #f))
  57.  
  58.  
  59. ;; Puck dynamic
  60. ;;
  61. (define puck-max-vx 2.2)
  62. (define puck-max-vy 2.2)
  63. (define puck-init-init-vx .5)
  64. (define puck-init-init-vy -.5)
  65. (define puck-init-vx .5)
  66. (define puck-init-vy -.5)
  67. (define puck-vx puck-init-vx)
  68. (define puck-vy puck-init-vy)
  69. (define (coin-toss . from)
  70.   (list-ref from (random (length from))))
  71. (define (puck-tick)
  72.   (let ((old-x puck-x)
  73.     (old-y puck-y))
  74.     (set! puck-x (+ puck-x puck-vx))
  75.     (set! puck-y (+ puck-y puck-vy))
  76.     (cond
  77.  
  78.      ((or (and (< puck-y (+ row1-y row-height))
  79.            (>= puck-y row1-y)
  80.            (hit-puck-at-game-x!? row1 puck-x)
  81.            row1-y)
  82.       (and (< puck-y (+ row0-y row-height))
  83.            (>= puck-y row0-y)
  84.            (hit-puck-at-game-x!? row0 puck-x)
  85.            row0-y)
  86.       (and (< puck-y 0)
  87.            0))
  88.       => (lambda (yref)
  89.        (report-score)
  90.        (set! puck-vy (- puck-vy))
  91.        (set! puck-y (+ yref (- puck-y yref)))
  92.        (if (= 0 n-blocks)
  93.            (begin
  94.          (win-level)
  95.          (set! old-y puck-y)
  96.          (set! old-x puck-x)))))
  97.  
  98.      ((<= bounds-h puck-y)
  99.       (cond
  100.        ((paddle-sweet? puck-x)
  101.     (begin
  102.       (set! puck-vy (- puck-vy))
  103.       (set! puck-y (+ bounds-h (- bounds-h puck-y)))))
  104.        ((paddle-sour? puck-x)
  105.     (begin
  106.       (set! puck-vy (- puck-vy))
  107.       (let ((total (+ (* puck-vx puck-vx) (* puck-vy puck-vy))))
  108.         (set! puck-vx ((coin-toss + -) (random puck-init-vx)))
  109.         (set! puck-vy (- (sqrt (- total (* puck-vx puck-vx))))))
  110.       (set! puck-y (+ bounds-h (- bounds-h puck-y)))))
  111.        (else
  112.     (lose-level)
  113.     (set! old-y puck-y)
  114.     (set! old-x puck-x))))
  115.        
  116.  
  117.      ((< puck-x 0)
  118.       (begin
  119.     (set! puck-vx (- puck-vx))
  120.     (set! puck-x (- puck-x))))
  121.  
  122.      ((<= bounds-w puck-x)
  123.       (begin
  124.     (set! puck-vx (- puck-vx))
  125.     (set! puck-x (+ bounds-w (- bounds-w puck-x))))))
  126.      
  127.     (move-puck  (- puck-x old-x) (- puck-y old-y))))
  128.  
  129.  
  130.  
  131. (define (paddle-sweet? x)
  132.   (and (> (abs puck-vx) .00001)
  133.        (let ((r (/ paddle-width 2)))
  134.      (< (abs (- x (+ r paddle-x)))
  135.         r))))
  136.  
  137. (define (paddle-sour? x)
  138.   (let ((r (/ paddle-width 2)))
  139.     (< (abs (- x (+ r paddle-x)))
  140.        (+ (* 3 puck-r) r))))
  141.  
  142.  
  143. ;; Hooks
  144.  
  145. (define n-blocks #f)
  146. (define (new-level)
  147.   (.game.c 'delete 'all)
  148.   (set! score-report #f)
  149.   (set! puck-report #f)
  150.   (set! game-over-report #f)
  151.   (make-row! row0 row0-y 'green)
  152.   (make-row! row1 row1-y 'blue)
  153.   (set! n-blocks (* 2 n-row))
  154.   (new-puck)
  155.   (new-paddle)
  156.   (report-game-state))
  157.  
  158. (define (new-game)
  159.   (set! game-playable #t)
  160.   (set! game-playing #f)
  161.   (set! puck-init-vx puck-init-init-vx)
  162.   (set! puck-init-vy puck-init-init-vy)
  163.   (new-level)
  164.   (set! n-pucks pucks-per-game)
  165.   (set! score 0))
  166.  
  167.  
  168. ;; Make the window and playing area
  169. ;;
  170. (define play-geom (string-append (number->string play-w)
  171.                  'x
  172.                  (number->string play-h)))
  173. (wm 'minsize '.game play-w play-h)
  174. (wm 'maxsize '.game play-w play-h)
  175. (wm 'geometry '.game play-geom)
  176. (canvas '.game.c)
  177. (pack '.game.c :fill "both" :expand #t)
  178.  
  179.  
  180.  
  181. ;; Make the two rows:
  182. ;;
  183. (define (make-row! v y color)
  184.   (let loop ((n 0))
  185.     (if (= n 16)
  186.     v
  187.     (begin
  188.       (vector-set! v n (.game.c 'create 'rectangle
  189.                     (+ bounds-x (* n row-width))
  190.                     (+ bounds-y y)
  191.                     (+ bounds-x (* (+ 1 n) row-width))
  192.                     (+ bounds-y (+ y row-height))
  193.                     :fill color
  194.                     :width 3))
  195.       (loop (+ n 1))))))
  196.  
  197. (define (hit-puck-at-game-x!? row x-game)
  198.   (let* ((x (- x-game bounds-x))
  199.      (i (inexact->exact (floor (/ x row-width)))))
  200.     (and (>= i 0)
  201.      (< i (vector-length row))
  202.      (vector-ref row i)
  203.      (begin
  204.        (.game.c 'delete (vector-ref row i))
  205.        (vector-set! row i #f)
  206.        (set! n-blocks (- n-blocks 1))
  207.        (set! score (+ 1 score))
  208.        #t))))
  209.  
  210.  
  211. ;; Drawing the paddle:
  212. ;;
  213. (define (paddle-x-max) (+ paddle-x paddle-width))
  214. (define (paddle-y-max) (+ paddle-y paddle-height))
  215. (define paddle-color 'red)
  216. (define paddle #f)
  217. (define (new-paddle)
  218.   (set! paddle
  219.     (.game.c 'create 'rectangle
  220.          (+ bounds-x paddle-x)
  221.          (+ bounds-y paddle-y)
  222.          (+ bounds-x (paddle-x-max))
  223.          (+ bounds-y (paddle-y-max))
  224.          :fill paddle-color)))
  225.  
  226. (define (center-paddle-at-canvas-coord x)
  227.   (let ((old-x paddle-x))
  228.     (set! paddle-x (- x bounds-x (/ paddle-width 2)))
  229.     (.game.c 'move paddle (- paddle-x old-x) 0)))
  230.  
  231.  
  232. ;; Drawing the puck:
  233. ;;
  234.  
  235. (define puck-color 'purple)
  236. (define puck #f)
  237. (define (new-puck)
  238.   (set! puck-y (- paddle-y puck-r 1))
  239.   (set! puck-x 0)
  240.   (set! puck-vx puck-init-vx)
  241.   (set! puck-vy puck-init-vy)
  242.   (set! puck 
  243.     (.game.c 'create 'oval
  244.          (+ bounds-x (- puck-x puck-r))
  245.          (+ bounds-y (- puck-y puck-r))
  246.          (+ bounds-x (+ puck-x puck-r))
  247.          (+ bounds-y (+ puck-y puck-r))
  248.          :fill puck-color)))
  249.  
  250. (define (move-puck dx dy)
  251.   (.game.c 'move puck dx dy))
  252.  
  253. (define (remove-puck)
  254.   (.game.c 'delete puck)
  255.   (new-puck))
  256.  
  257.  
  258.  
  259. (bind '.game.c "<Motion>"
  260.       (tcl-lambda ("%x %y" (number x) (number y))
  261.     (center-paddle-at-canvas-coord x)
  262.     ""))
  263.  
  264.  
  265.  
  266. (define (loop)
  267.   (let loop ()
  268.     (puck-tick)
  269.     (update)
  270.     (if game-playing
  271.     (loop))))
  272.  
  273.  
  274.  
  275.  
  276. (define game-playable #t)
  277. (define game-playing #f)
  278. (define score 0)
  279. (define pucks-per-game 3)
  280. (define n-pucks pucks-per-game)
  281. (define score-report #f)
  282. (define puck-report #f)
  283. (define game-over-report #f)
  284.  
  285. (define (lose-level)
  286.   (remove-puck)
  287.   (set! game-playing #f)
  288.   (if (> n-pucks 0)
  289.       (begin
  290.     (set! n-pucks (+ -1 n-pucks)))
  291.       (set! game-playable #f)))
  292.  
  293. (define (win-level)
  294.   (set! n-pucks (+ 1 n-pucks))
  295.   (remove-puck)
  296.   (set! game-playing #f)
  297.   (set! score (+ 25 score))
  298.   (set! puck-init-vy (* puck-init-vy 2))
  299.   (set! puck-init-vx (* puck-init-vx 2))
  300.   (if (< puck-init-vx puck-max-vx)
  301.       (new-level)
  302.       (set! game-playable #f)))
  303.  
  304.  
  305. (define (report-score)
  306.   (and score-report (.game.c 'delete score-report))
  307.   (set! score-report
  308.     (.game.c 'create 'text 10 (+ 64 paddle-y)
  309.          :font "-adobe-helvetica-bold-r-normal-*-24-*-*-*-*-*-*-*"
  310.          :anchor 'w))
  311.   (.game.c 'insert score-report 0
  312.        (string-append "Score: " (number->string score))))
  313.  
  314.  
  315. (define (report-game-state)  
  316.   (report-score)
  317.   (and puck-report (.game.c 'delete puck-report))
  318.   (set! puck-report
  319.     (.game.c 'create 'text 200 (+ 64 paddle-y)
  320.          :font "-adobe-helvetica-bold-r-normal-*-24-*-*-*-*-*-*-*"
  321.          :fill (cond
  322.             ((not game-playable) 'thistle4)
  323.             ((eq? n-pucks 0) 'red)
  324.             (else 'navy))
  325.          :anchor 'w))
  326.   (.game.c 'insert puck-report 0
  327.        (if (not game-playable)
  328.            "GAME OVER"
  329.            (string-append "Pucks remaining: " (number->string n-pucks))))
  330.   (and game-over-report (.game.c 'delete game-over-report))
  331.   (set! game-over-report
  332.     (.game.c 'create 'text 10 (+ 96 paddle-y)
  333.          :font "-adobe-helvetica-bold-o-normal-*-18-*-*-*-*-*-*-*"
  334.          :fill (if (not game-playable) 'red 'ForestGreen)
  335.          :anchor 'w))
  336.   (.game.c 'insert game-over-report 0
  337.        (cond
  338.         ((not game-playable) "`P' to start a new game;  `Q' to quit")
  339.         (game-playing "`P' to pause;  `Q' to quit this game")
  340.         (else  "`P' to play;  `Q' to quit"))))
  341.  
  342.  
  343. (define (play-game)
  344.   (if (not game-playable) (new-game))
  345.   (set! game-playing #t)
  346.   (report-game-state)
  347.   (loop)
  348.   (report-game-state))
  349.  
  350.  
  351.  
  352. (proc game-q ignored
  353.       (cond
  354.        (game-playing (set! game-playing #f) (new-game))
  355.        ((not game-playable)
  356.     (new-game)
  357.     (report-game-state))
  358.        (else (destroy '.game))))
  359.  
  360. (proc game-p ignored
  361.       (cond
  362.        (game-playing (set! game-playing #f))
  363.        (else (play-game))))
  364.  
  365. (bind '.game.c '<q> 'game-q)
  366. (bind '.game.c '<Q> 'game-q)
  367.  
  368. (bind '.game.c '<p> 'game-p)
  369. (bind '.game.c '<P> 'game-p)
  370. (focus '.game.c)
  371. (new-game)
  372.